Through mapping both covid tests and positives adjusted for population, we hope to fine if any relation between the two exists. It may be possible that more tests mean more covid.

Load packages

The following packages are used:

knitr– load datasets

tidverse– mutate data

janitor– clean names

lubridate – work with dates

here– give file locations

library(knitr)
library(tidyverse)
library(janitor)
library(lubridate)
library(here)

Additional packages being used

tmap– for mapping purposes

sf– joining spacial data and generating plots

tidycensus– loading census data

library(tmap)
library(sf)
library(tidycensus)

Load testing data

The test data is loaded into R, and mutated to become non-cumulative

df1=readxl::read_excel(here("submissions","bike_share","data","tot_tests_neighborhood.xlsx")) %>% 
  clean_names() %>%
  #mutate(date_reported= as_datetime(date_reported))
  separate(date_reported,into=c("date","hr"),sep = " ")%>%
  mutate(date_report=as_date(date))%>%
  group_by(neighborhood)%>%
  mutate(across(total_tests, ~ .-c(0,lag(.)[-1])))

Load Mapping Data

Loads in the Health neighbourhood geojson file.

neigh=st_read(here("submissions","bike_share","data","dc_neigh.geojson")) %>% clean_names()
Reading layer `DC_Health_Planning_Neighborhoods' from data source 
  `D:\KALTENBACH_ENGINEERING\Master\CU\R_Workspace\Portfolio_DS\submissions\bike_share\data\dc_neigh.geojson' 
  using driver `GeoJSON'
Simple feature collection with 51 features and 8 fields
Geometry type: POLYGON
Dimension:     XY
Bounding box:  xmin: -77.11976 ymin: 38.79165 xmax: -76.9094 ymax: 38.99556
Geodetic CRS:  WGS 84
class(neigh)
[1] "sf"         "data.frame"

Select and clean data

Cleans testing data so it can be joined with the health neighborhood spacial data

df_tests=df1 %>%
  filter(as_date(date_report) == "2021/10/27") %>% 
  separate(neighborhood,into=c("code","name"),sep = ":") %>% 
  mutate(code=case_when(
    code=="N35" ~"N0",
    TRUE ~ code
  ))

Join mapping data with test data

Joins data and generates plot

neigh2=left_join(neigh,df_tests,by=c("code")) 
tmap_mode("view")
tmap mode set to interactive viewing
tm_shape(neigh2) +tm_polygons("total_tests",alpha=.5)

Load positive cases data

Reads in positive coivd cases data and cleans it so it can be joined to the above datasets

df_c=readxl::read_excel(here("submissions","bike_share","data","neigh_cases.xlsx"),
                            col_types = c("date", "text", "numeric")) %>% 
  clean_names() 
df_cases=df_c %>%
  filter(as_date(date) == "2021/10/27") %>% 
  separate(neighborhood,into=c("code","name"),sep = ":") %>%
  mutate(code=case_when(
    code=="N35" ~"N0",
    TRUE ~ code
  ))

Join covid data

neigh3=left_join(neigh2,df_cases,by=c("code")) 
tmap_mode("view")
tmap mode set to interactive viewing
tm_shape(neigh3) +tm_polygons("total_positives",alpha=.5)

Graph data

 tm_shape(neigh3)+tm_polygons(c("total_positives","total_tests"),alpha=.5)

Get census Data

Census data is used to normalize both tests and COVID data for population

census_api_key("2c8b9d5c4902b7efb4e1f98b2c23692cb1b73e95")
To install your API key for use in future sessions, run this function with `install = TRUE`.
v20 = load_variables(2018,"acs5")
df_cencus=get_acs(geography = "tract",
                  variables=c("pop"="B01001_001"),
                  state="DC",geometry=TRUE,year=2018) 
Getting data from the 2014-2018 5-year ACS
Downloading feature geometry from the Census website.  To cache shapefiles for use in future sessions, set `options(tigris_use_cache = TRUE)`.
Using FIPS code '11' for state 'DC'
df_cens=df_cencus %>% select(-moe) %>% spread(variable,estimate) 
df_cens_adj=df_cens %>% st_transform(4326)

Join Census data to mapping data

df_j=st_join(df_cens_adj,neigh3,largest=TRUE)
Warning: attribute variables are assumed to be spatially constant throughout all geometries

Summarize population for each neighbourhood

df3=df_j %>% select(pop,code) %>%
  group_by(code) %>%
  summarise(pop_n=sum(pop))
            
            

Join population data and generate results

Removed any extreme outliers and generated map to compare testing rates and covid rates

df4=left_join(neigh3,df3 %>% st_set_geometry(NULL))
Joining, by = "code"
df4=df4 %>% mutate( covid_rate=total_positives/pop_n, test_rate=total_tests/pop_n)
df4 %>% filter(!(code %in% c("N0","N15","N24"))) %>% tm_shape()+tm_polygons(c("covid_rate","test_rate"))
LS0tDQp0aXRsZTogIkNvbXBhcmluZyBDb3ZpZCBUZXN0cyBhbmQgQ292aWQgUG9zaXRpdmVzIHVzaW5nIG1hcHBpbmcgZGF0YSINCmF1dGhvcjogIlRlYW0gNCAtIENvdmlkIERhdGEiDQpvdXRwdXQ6IGh0bWxfbm90ZWJvb2sNCi0tLQ0KDQpUaHJvdWdoIG1hcHBpbmcgYm90aCBjb3ZpZCB0ZXN0cyBhbmQgcG9zaXRpdmVzIGFkanVzdGVkIGZvciBwb3B1bGF0aW9uLCB3ZSBob3BlIHRvIGZpbmUgaWYgYW55IHJlbGF0aW9uIGJldHdlZW4gdGhlIHR3byBleGlzdHMuIEl0IG1heSBiZSBwb3NzaWJsZSB0aGF0IG1vcmUgdGVzdHMgbWVhbiBtb3JlIGNvdmlkLg0KDQojIyMgTG9hZCBwYWNrYWdlcw0KDQpUaGUgZm9sbG93aW5nIHBhY2thZ2VzIGFyZSB1c2VkOg0KDQprbml0ci0tIGxvYWQgZGF0YXNldHMNCg0KdGlkdmVyc2UtLSBtdXRhdGUgZGF0YQ0KDQpqYW5pdG9yLS0gY2xlYW4gbmFtZXMNCg0KbHVicmlkYXRlIC0tIHdvcmsgd2l0aCBkYXRlcw0KDQpoZXJlLS0gZ2l2ZSBmaWxlIGxvY2F0aW9ucw0KDQpgYGB7cn0NCmxpYnJhcnkoa25pdHIpDQpsaWJyYXJ5KHRpZHl2ZXJzZSkNCmxpYnJhcnkoamFuaXRvcikNCmxpYnJhcnkobHVicmlkYXRlKQ0KbGlicmFyeShoZXJlKQ0KYGBgDQoNCg0KIyMjIEFkZGl0aW9uYWwgcGFja2FnZXMgYmVpbmcgdXNlZA0KDQp0bWFwLS0gZm9yIG1hcHBpbmcgcHVycG9zZXMNCg0Kc2YtLSBqb2luaW5nIHNwYWNpYWwgZGF0YSBhbmQgZ2VuZXJhdGluZyBwbG90cw0KDQp0aWR5Y2Vuc3VzLS0gbG9hZGluZyBjZW5zdXMgZGF0YQ0KDQpgYGB7ciBtZXNzYWdlPUZBTFNFLCB3YXJuaW5nPUZBTFNFfQ0KbGlicmFyeSh0bWFwKQ0KbGlicmFyeShzZikNCmxpYnJhcnkodGlkeWNlbnN1cykNCmBgYA0KDQojIyMgTG9hZCB0ZXN0aW5nIGRhdGENCg0KVGhlIHRlc3QgZGF0YSBpcyBsb2FkZWQgaW50byBSLCBhbmQgbXV0YXRlZCB0byBiZWNvbWUgbm9uLWN1bXVsYXRpdmUNCg0KYGBge3IgbWVzc2FnZT1GQUxTRSwgd2FybmluZz1GQUxTRX0NCmRmMT1yZWFkeGw6OnJlYWRfZXhjZWwoaGVyZSgic3VibWlzc2lvbnMiLCJiaWtlX3NoYXJlIiwiZGF0YSIsInRvdF90ZXN0c19uZWlnaGJvcmhvb2QueGxzeCIpKSAlPiUgDQogIGNsZWFuX25hbWVzKCkgJT4lDQogICNtdXRhdGUoZGF0ZV9yZXBvcnRlZD0gYXNfZGF0ZXRpbWUoZGF0ZV9yZXBvcnRlZCkpDQogIHNlcGFyYXRlKGRhdGVfcmVwb3J0ZWQsaW50bz1jKCJkYXRlIiwiaHIiKSxzZXAgPSAiICIpJT4lDQogIG11dGF0ZShkYXRlX3JlcG9ydD1hc19kYXRlKGRhdGUpKSU+JQ0KICBncm91cF9ieShuZWlnaGJvcmhvb2QpJT4lDQogIG11dGF0ZShhY3Jvc3ModG90YWxfdGVzdHMsIH4gLi1jKDAsbGFnKC4pWy0xXSkpKQ0KYGBgDQoNCg0KIyMjIExvYWQgTWFwcGluZyBEYXRhDQoNCkxvYWRzIGluIHRoZSBIZWFsdGggbmVpZ2hib3VyaG9vZCBnZW9qc29uIGZpbGUuDQoNCmBgYHtyIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9DQpuZWlnaD1zdF9yZWFkKGhlcmUoInN1Ym1pc3Npb25zIiwiYmlrZV9zaGFyZSIsImRhdGEiLCJkY19uZWlnaC5nZW9qc29uIikpICU+JSBjbGVhbl9uYW1lcygpDQpjbGFzcyhuZWlnaCkNCmBgYA0KDQojIyMgU2VsZWN0IGFuZCBjbGVhbiBkYXRhDQoNCkNsZWFucyB0ZXN0aW5nIGRhdGEgc28gaXQgY2FuIGJlIGpvaW5lZCB3aXRoIHRoZSBoZWFsdGggbmVpZ2hib3Job29kIHNwYWNpYWwgZGF0YQ0KDQpgYGB7cn0NCmRmX3Rlc3RzPWRmMSAlPiUNCiAgZmlsdGVyKGFzX2RhdGUoZGF0ZV9yZXBvcnQpID09ICIyMDIxLzEwLzI3IikgJT4lIA0KICBzZXBhcmF0ZShuZWlnaGJvcmhvb2QsaW50bz1jKCJjb2RlIiwibmFtZSIpLHNlcCA9ICI6IikgJT4lIA0KICBtdXRhdGUoY29kZT1jYXNlX3doZW4oDQogICAgY29kZT09Ik4zNSIgfiJOMCIsDQogICAgVFJVRSB+IGNvZGUNCiAgKSkNCmBgYA0KDQojIyMgSm9pbiBtYXBwaW5nIGRhdGEgd2l0aCB0ZXN0IGRhdGENCg0KSm9pbnMgZGF0YSBhbmQgZ2VuZXJhdGVzIHBsb3QNCg0KYGBge3IgbWVzc2FnZT1GQUxTRSwgd2FybmluZz1GQUxTRX0NCm5laWdoMj1sZWZ0X2pvaW4obmVpZ2gsZGZfdGVzdHMsYnk9YygiY29kZSIpKSANCnRtYXBfbW9kZSgidmlldyIpDQp0bV9zaGFwZShuZWlnaDIpICt0bV9wb2x5Z29ucygidG90YWxfdGVzdHMiLGFscGhhPS41KQ0KYGBgDQoNCiMjIyBMb2FkIHBvc2l0aXZlIGNhc2VzIGRhdGENCg0KUmVhZHMgaW4gcG9zaXRpdmUgY29pdmQgY2FzZXMgZGF0YSBhbmQgY2xlYW5zIGl0IHNvIGl0IGNhbiBiZSBqb2luZWQgdG8gdGhlIGFib3ZlIGRhdGFzZXRzDQoNCmBgYHtyIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9DQpkZl9jPXJlYWR4bDo6cmVhZF9leGNlbChoZXJlKCJzdWJtaXNzaW9ucyIsImJpa2Vfc2hhcmUiLCJkYXRhIiwibmVpZ2hfY2FzZXMueGxzeCIpLA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgIGNvbF90eXBlcyA9IGMoImRhdGUiLCAidGV4dCIsICJudW1lcmljIikpICU+JSANCiAgY2xlYW5fbmFtZXMoKSANCmRmX2Nhc2VzPWRmX2MgJT4lDQogIGZpbHRlcihhc19kYXRlKGRhdGUpID09ICIyMDIxLzEwLzI3IikgJT4lIA0KICBzZXBhcmF0ZShuZWlnaGJvcmhvb2QsaW50bz1jKCJjb2RlIiwibmFtZSIpLHNlcCA9ICI6IikgJT4lDQogIG11dGF0ZShjb2RlPWNhc2Vfd2hlbigNCiAgICBjb2RlPT0iTjM1IiB+Ik4wIiwNCiAgICBUUlVFIH4gY29kZQ0KICApKQ0KYGBgDQoNCiMjIyBKb2luIGNvdmlkIGRhdGENCg0KYGBge3J9DQpuZWlnaDM9bGVmdF9qb2luKG5laWdoMixkZl9jYXNlcyxieT1jKCJjb2RlIikpIA0KdG1hcF9tb2RlKCJ2aWV3IikNCnRtX3NoYXBlKG5laWdoMykgK3RtX3BvbHlnb25zKCJ0b3RhbF9wb3NpdGl2ZXMiLGFscGhhPS41KQ0KYGBgDQoNCiMjIyBHcmFwaCBkYXRhDQoNCmBgYHtyfQ0KIHRtX3NoYXBlKG5laWdoMykrdG1fcG9seWdvbnMoYygidG90YWxfcG9zaXRpdmVzIiwidG90YWxfdGVzdHMiKSxhbHBoYT0uNSkNCmBgYA0KDQojIyMgR2V0IGNlbnN1cyBEYXRhDQoNCkNlbnN1cyBkYXRhIGlzIHVzZWQgdG8gbm9ybWFsaXplIGJvdGggdGVzdHMgYW5kIENPVklEIGRhdGEgZm9yIHBvcHVsYXRpb24NCg0KYGBge3J9DQpjZW5zdXNfYXBpX2tleSgiMmM4YjlkNWM0OTAyYjdlZmI0ZTFmOThiMmMyMzY5MmNiMWI3M2U5NSIpDQoNCnYyMCA9IGxvYWRfdmFyaWFibGVzKDIwMTgsImFjczUiKQ0KZGZfY2VuY3VzPWdldF9hY3MoZ2VvZ3JhcGh5ID0gInRyYWN0IiwNCiAgICAgICAgICAgICAgICAgIHZhcmlhYmxlcz1jKCJwb3AiPSJCMDEwMDFfMDAxIiksDQogICAgICAgICAgICAgICAgICBzdGF0ZT0iREMiLGdlb21ldHJ5PVRSVUUseWVhcj0yMDE4KSANCg0KZGZfY2Vucz1kZl9jZW5jdXMgJT4lIHNlbGVjdCgtbW9lKSAlPiUgc3ByZWFkKHZhcmlhYmxlLGVzdGltYXRlKSANCmRmX2NlbnNfYWRqPWRmX2NlbnMgJT4lIHN0X3RyYW5zZm9ybSg0MzI2KQ0KYGBgDQoNCiMjIyBKb2luIENlbnN1cyBkYXRhIHRvIG1hcHBpbmcgZGF0YQ0KYGBge3J9DQpkZl9qPXN0X2pvaW4oZGZfY2Vuc19hZGosbmVpZ2gzLGxhcmdlc3Q9VFJVRSkNCmBgYA0KDQojIyMgU3VtbWFyaXplIHBvcHVsYXRpb24gZm9yIGVhY2ggbmVpZ2hib3VyaG9vZA0KYGBge3J9DQpkZjM9ZGZfaiAlPiUgc2VsZWN0KHBvcCxjb2RlKSAlPiUNCiAgZ3JvdXBfYnkoY29kZSkgJT4lDQogIHN1bW1hcmlzZShwb3Bfbj1zdW0ocG9wKSkNCiAgICAgICAgICAgIA0KICAgICAgICAgICAgDQpgYGANCg0KIyMjIEpvaW4gcG9wdWxhdGlvbiBkYXRhIGFuZCBnZW5lcmF0ZSByZXN1bHRzDQoNClJlbW92ZWQgYW55IGV4dHJlbWUgb3V0bGllcnMgYW5kIGdlbmVyYXRlZCBtYXAgdG8gY29tcGFyZSB0ZXN0aW5nIHJhdGVzIGFuZCBjb3ZpZCByYXRlcw0KDQpgYGB7cn0NCmRmND1sZWZ0X2pvaW4obmVpZ2gzLGRmMyAlPiUgc3Rfc2V0X2dlb21ldHJ5KE5VTEwpKQ0KDQpkZjQ9ZGY0ICU+JSBtdXRhdGUoIGNvdmlkX3JhdGU9dG90YWxfcG9zaXRpdmVzL3BvcF9uLCB0ZXN0X3JhdGU9dG90YWxfdGVzdHMvcG9wX24pDQpkZjQgJT4lIGZpbHRlcighKGNvZGUgJWluJSBjKCJOMCIsIk4xNSIsIk4yNCIpKSkgJT4lIHRtX3NoYXBlKCkrdG1fcG9seWdvbnMoYygiY292aWRfcmF0ZSIsInRlc3RfcmF0ZSIpKQ0KYGBgDQoNCg0K